home *** CD-ROM | disk | FTP | other *** search
/ Amiga Tools 5 / Amiga Tools 5.iso / tools / developer-tools / andere sprachen / perl5 / perl5.002 / x2p / find2perl.pl < prev    next >
Encoding:
Perl Script  |  1996-01-23  |  13.1 KB  |  608 lines
  1. #!/usr/local/bin/perl
  2.  
  3. use Config;
  4. use File::Basename qw(&basename &dirname);
  5.  
  6. # List explicitly here the variables you want Configure to
  7. # generate.  Metaconfig only looks for shell variables, so you
  8. # have to mention them as if they were shell variables, not
  9. # %Config entries.  Thus you write
  10. #  $startperl
  11. # to ensure Configure will look for $Config{startperl}.
  12.  
  13. # This forces PL files to create target in same directory as PL file.
  14. # This is so that make depend always knows where to find PL derivatives.
  15. chdir(dirname($0));
  16. ($file = basename($0)) =~ s/\.PL$//;
  17. $file =~ s/\.pl$//
  18.     if ($Config{'osname'} eq 'VMS' or
  19.         $Config{'osname'} eq 'OS2');  # "case-forgiving"
  20.  
  21. open OUT,">$file" or die "Can't create $file: $!";
  22.  
  23. print "Extracting $file (with variable substitutions)\n";
  24.  
  25. # In this section, perl variables will be expanded during extraction.
  26. # You can use $Config{...} to use Configure variables.
  27.  
  28. print OUT <<"!GROK!THIS!";
  29. $Config{'startperl'}
  30.     eval 'exec perl -S \$0 "\$@"'
  31.     if 0;
  32. \$startperl = "$Config{startperl}";
  33. !GROK!THIS!
  34.  
  35. # In the following, perl variables are not expanded during extraction.
  36.  
  37. print OUT <<'!NO!SUBS!';
  38. # 
  39. # Modified September 26, 1993 to provide proper handling of years after 1999
  40. #   Tom Link <tml+@pitt.edu>
  41. #   University of Pittsburgh
  42.  
  43. while ($ARGV[0] =~ /^[^-!(]/) {
  44.     push(@roots, shift);
  45. }
  46. @roots = ('.') unless @roots;
  47. for (@roots) { $_ = "e($_); }
  48. $roots = join(',', @roots);
  49.  
  50. $indent = 1;
  51.  
  52. while (@ARGV) {
  53.     $_ = shift;
  54.     s/^-// || /^[()!]/ || die "Unrecognized switch: $_\n";
  55.     if ($_ eq '(') {
  56.     $out .= &tab . "(\n";
  57.     $indent++;
  58.     next;
  59.     }
  60.     elsif ($_ eq ')') {
  61.     $indent--;
  62.     $out .= &tab . ")";
  63.     }
  64.     elsif ($_ eq '!') {
  65.     $out .= &tab . "!";
  66.     next;
  67.     }
  68.     elsif ($_ eq 'name') {
  69.     $out .= &tab;
  70.     $pat = &fileglob_to_re(shift);
  71.     $out .= '/' . $pat . "/";
  72.     }
  73.     elsif ($_ eq 'perm') {
  74.     $onum = shift;
  75.     die "Malformed -perm argument: $onum\n" unless $onum =~ /^-?[0-7]+$/;
  76.     if ($onum =~ s/^-//) {
  77.         $onum = '0' . sprintf("%o", oct($onum) & 017777);    # s/b 07777 ?
  78.         $out .= &tab . "((\$mode & $onum) == $onum)";
  79.     }
  80.     else {
  81.         $onum = '0' . $onum unless $onum =~ /^0/;
  82.         $out .= &tab . "((\$mode & 0777) == $onum)";
  83.     }
  84.     }
  85.     elsif ($_ eq 'type') {
  86.     ($filetest = shift) =~ tr/s/S/;
  87.     $out .= &tab . "-$filetest _";
  88.     }
  89.     elsif ($_ eq 'print') {
  90.     $out .= &tab . 'print("$name\n")';
  91.     }
  92.     elsif ($_ eq 'print0') {
  93.     $out .= &tab . 'print("$name\0")';
  94.     }
  95.     elsif ($_ eq 'fstype') {
  96.     $out .= &tab;
  97.     $type = shift;
  98.     if ($type eq 'nfs')
  99.         { $out .= '($dev < 0)'; }
  100.     else
  101.         { $out .= '($dev >= 0)'; }
  102.     }
  103.     elsif ($_ eq 'user') {
  104.     $uname = shift;
  105.     $out .= &tab . "(\$uid == \$uid{'$uname'})";
  106.     $inituser++;
  107.     }
  108.     elsif ($_ eq 'group') {
  109.     $gname = shift;
  110.     $out .= &tab . "(\$gid == \$gid{'$gname'})";
  111.     $initgroup++;
  112.     }
  113.     elsif ($_ eq 'nouser') {
  114.     $out .= &tab . '!defined $uid{$uid}';
  115.     $inituser++;
  116.     }
  117.     elsif ($_ eq 'nogroup') {
  118.     $out .= &tab . '!defined $gid{$gid}';
  119.     $initgroup++;
  120.     }
  121.     elsif ($_ eq 'links') {
  122.     $out .= &tab . '($nlink ' . &n(shift);
  123.     }
  124.     elsif ($_ eq 'inum') {
  125.     $out .= &tab . '($ino ' . &n(shift);
  126.     }
  127.     elsif ($_ eq 'size') {
  128.     $out .= &tab . '(int(((-s _) + 511) / 512) ' . &n(shift);
  129.     }
  130.     elsif ($_ eq 'atime') {
  131.     $out .= &tab . '(int(-A _) ' . &n(shift);
  132.     }
  133.     elsif ($_ eq 'mtime') {
  134.     $out .= &tab . '(int(-M _) ' . &n(shift);
  135.     }
  136.     elsif ($_ eq 'ctime') {
  137.     $out .= &tab . '(int(-C _) ' . &n(shift);
  138.     }
  139.     elsif ($_ eq 'exec') {
  140.     for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { }
  141.     shift;
  142.     $_ = "@cmd";
  143.     if (m#^(/bin/)?rm -f {}$#) {
  144.         if (!@ARGV) {
  145.         $out .= &tab . 'unlink($_)';
  146.         }
  147.         else {
  148.         $out .= &tab . '(unlink($_) || 1)';
  149.         }
  150.     }
  151.     elsif (m#^(/bin/)?rm {}$#) {
  152.         $out .= &tab . '(unlink($_) || warn "$name: $!\n")';
  153.     }
  154.     else {
  155.         for (@cmd) { s/'/\\'/g; }
  156.         $" = "','";
  157.         $out .= &tab . "&exec(0, '@cmd')";
  158.         $" = ' ';
  159.         $initexec++;
  160.     }
  161.     }
  162.     elsif ($_ eq 'ok') {
  163.     for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { }
  164.     shift;
  165.     for (@cmd) { s/'/\\'/g; }
  166.     $" = "','";
  167.     $out .= &tab . "&exec(1, '@cmd')";
  168.     $" = ' ';
  169.     $initexec++;
  170.     }
  171.     elsif ($_ eq 'prune') {
  172.     $out .= &tab . '($prune = 1)';
  173.     }
  174.     elsif ($_ eq 'xdev') {
  175.     $out .= &tab . '!($prune |= ($dev != $topdev))';
  176.     }
  177.     elsif ($_ eq 'newer') {
  178.     $out .= &tab;
  179.     $file = shift;
  180.     $newername = 'AGE_OF' . $file;
  181.     $newername =~ s/[^\w]/_/g;
  182.     $newername = '$' . $newername;
  183.     $out .= "(-M _ < $newername)";
  184.     $initnewer .= "$newername = -M " . "e($file) . ";\n";
  185.     }
  186.     elsif ($_ eq 'eval') {
  187.     $prog = "e(shift);
  188.     $out .= &tab . "eval $prog";
  189.     }
  190.     elsif ($_ eq 'depth') {
  191.     $depth++;
  192.     next;
  193.     }
  194.     elsif ($_ eq 'ls') {
  195.     $out .= &tab . "&ls";
  196.     $initls++;
  197.     }
  198.     elsif ($_ eq 'tar') {
  199.     $out .= &tab;
  200.     die "-tar must have a filename argument\n" unless @ARGV;
  201.     $file = shift;
  202.     $fh = 'FH' . $file;
  203.     $fh =~ s/[^\w]/_/g;
  204.     $out .= "&tar($fh)";
  205.     $file = '>' . $file;
  206.     $initfile .= "open($fh, " . "e($file) .
  207.       qq{) || die "Can't open $fh: \$!\\n";\n};
  208.     $inittar++;
  209.     $flushall = "\n&tflushall;\n";
  210.     }
  211.     elsif (/^n?cpio$/) {
  212.     $depth++;
  213.     $out .= &tab;
  214.     die "-$_ must have a filename argument\n" unless @ARGV;
  215.     $file = shift;
  216.     $fh = 'FH' . $file;
  217.     $fh =~ s/[^\w]/_/g;
  218.     $out .= "&cpio('" . substr($_,0,1) . "', $fh)";
  219.     $file = '>' . $file;
  220.     $initfile .= "open($fh, " . "e($file) .
  221.       qq{) || die "Can't open $fh: \$!\\n";\n};
  222.     $initcpio++;
  223.     $flushall = "\n&flushall;\n";
  224.     }
  225.     else {
  226.     die "Unrecognized switch: -$_\n";
  227.     }
  228.     if (@ARGV) {
  229.     if ($ARGV[0] eq '-o') {
  230.         { local($statdone) = 1; $out .= "\n" . &tab . "||\n"; }
  231.         $statdone = 0 if $indent == 1 && $delayedstat;
  232.         $saw_or++;
  233.         shift;
  234.     }
  235.     else {
  236.         $out .= " &&" unless $ARGV[0] eq ')';
  237.         $out .= "\n";
  238.         shift if $ARGV[0] eq '-a';
  239.     }
  240.     }
  241. }
  242.  
  243. print <<"END";
  244. $startperl
  245.  
  246. eval 'exec perl -S \$0 \${1+"\$@"}'
  247.     if \$running_under_some_shell;
  248.  
  249. END
  250.  
  251. if ($initls) {
  252.     print <<'END';
  253. @rwx = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
  254. @moname = (Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec);
  255.  
  256. END
  257. }
  258.  
  259. if ($inituser || $initls) {
  260.     print 'while (($name, $pw, $uid) = getpwent) {', "\n";
  261.     print '    $uid{$name} = $uid{$uid} = $uid;', "\n" if $inituser;
  262.     print '    $user{$uid} = $name unless $user{$uid};', "\n" if $initls;
  263.     print "}\n\n";
  264. }
  265.  
  266. if ($initgroup || $initls) {
  267.     print 'while (($name, $pw, $gid) = getgrent) {', "\n";
  268.     print '    $gid{$name} = $gid{$gid} = $gid;', "\n" if $initgroup;
  269.     print '    $group{$gid} = $name unless $group{$gid};', "\n" if $initls;
  270.     print "}\n\n";
  271. }
  272.  
  273. print $initnewer, "\n" if $initnewer;
  274.  
  275. print $initfile, "\n" if $initfile;
  276.  
  277. $find = $depth ? "finddepth" : "find";
  278. print <<"END";
  279. require "$find.pl";
  280.  
  281. # Traverse desired filesystems
  282.  
  283. &$find($roots);
  284. $flushall
  285. exit;
  286.  
  287. sub wanted {
  288. $out;
  289. }
  290.  
  291. END
  292.  
  293. if ($initexec) {
  294.     print <<'END';
  295. sub exec {
  296.     local($ok, @cmd) = @_;
  297.     foreach $word (@cmd) {
  298.     $word =~ s#{}#$name#g;
  299.     }
  300.     if ($ok) {
  301.     local($old) = select(STDOUT);
  302.     $| = 1;
  303.     print "@cmd";
  304.     select($old);
  305.     return 0 unless <STDIN> =~ /^y/;
  306.     }
  307.     chdir $cwd;        # sigh
  308.     system @cmd;
  309.     chdir $dir;
  310.     return !$?;
  311. }
  312.  
  313. END
  314. }
  315.  
  316. if ($initls) {
  317.     print <<'END';
  318. sub ls {
  319.     ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
  320.       $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_);
  321.  
  322.     $pname = $name;
  323.  
  324.     if (defined $blocks) {
  325.     $blocks = int(($blocks + 1) / 2);
  326.     }
  327.     else {
  328.     $blocks = int(($size + 1023) / 1024);
  329.     }
  330.  
  331.     if    (-f _) { $perms = '-'; }
  332.     elsif (-d _) { $perms = 'd'; }
  333.     elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
  334.     elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
  335.     elsif (-p _) { $perms = 'p'; }
  336.     elsif (-S _) { $perms = 's'; }
  337.     else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
  338.  
  339.     $tmpmode = $mode;
  340.     $tmp = $rwx[$tmpmode & 7];
  341.     $tmpmode >>= 3;
  342.     $tmp = $rwx[$tmpmode & 7] . $tmp;
  343.     $tmpmode >>= 3;
  344.     $tmp = $rwx[$tmpmode & 7] . $tmp;
  345.     substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
  346.     substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
  347.     substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
  348.     $perms .= $tmp;
  349.  
  350.     $user = $user{$uid} || $uid;
  351.     $group = $group{$gid} || $gid;
  352.  
  353.     ($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
  354.     $moname = $moname[$mon];
  355.     if (-M _ > 365.25 / 2) {
  356.     $timeyear = $year + 1900;
  357.     }
  358.     else {
  359.     $timeyear = sprintf("%02d:%02d", $hour, $min);
  360.     }
  361.  
  362.     printf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
  363.         $ino,
  364.          $blocks,
  365.               $perms,
  366.                 $nlink,
  367.                 $user,
  368.                      $group,
  369.                       $sizemm,
  370.                           $moname,
  371.                          $mday,
  372.                              $timeyear,
  373.                              $pname;
  374.     1;
  375. }
  376.  
  377. sub sizemm {
  378.     sprintf("%3d, %3d", ($rdev >> 8) & 255, $rdev & 255);
  379. }
  380.  
  381. END
  382. }
  383.  
  384. if ($initcpio) {
  385. print <<'END';
  386. sub cpio {
  387.     local($nc,$fh) = @_;
  388.     local($text);
  389.  
  390.     if ($name eq 'TRAILER!!!') {
  391.     $text = '';
  392.     $size = 0;
  393.     }
  394.     else {
  395.     ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
  396.       $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_);
  397.     if (-f _) {
  398.         open(IN, "./$_\0") || do {
  399.         warn "Couldn't open $name: $!\n";
  400.         return;
  401.         };
  402.     }
  403.     else {
  404.         $text = readlink($_);
  405.         $size = 0 unless defined $text;
  406.     }
  407.     }
  408.  
  409.     ($nm = $name) =~ s#^\./##;
  410.     $nc{$fh} = $nc;
  411.     if ($nc eq 'n') {
  412.     $cpout{$fh} .=
  413.       sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0",
  414.         070707,
  415.         $dev & 0777777,
  416.         $ino & 0777777,
  417.         $mode & 0777777,
  418.         $uid & 0777777,
  419.         $gid & 0777777,
  420.         $nlink & 0777777,
  421.         $rdev & 0177777,
  422.         $mtime,
  423.         length($nm)+1,
  424.         $size,
  425.         $nm);
  426.     }
  427.     else {
  428.     $cpout{$fh} .= "\0" if length($cpout{$fh}) & 1;
  429.     $cpout{$fh} .= pack("SSSSSSSSLSLa*",
  430.         070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime,
  431.         length($nm)+1, $size, $nm . (length($nm) & 1 ? "\0" : "\0\0"));
  432.     }
  433.     if ($text ne '') {
  434.     $cpout{$fh} .= $text;
  435.     }
  436.     elsif ($size) {
  437.     &flush($fh) while ($l = length($cpout{$fh})) >= 5120;
  438.     while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) {
  439.         &flush($fh);
  440.         $l = length($cpout{$fh});
  441.     }
  442.     }
  443.     close IN;
  444. }
  445.  
  446. sub flush {
  447.     local($fh) = @_;
  448.  
  449.     while (length($cpout{$fh}) >= 5120) {
  450.     syswrite($fh,$cpout{$fh},5120);
  451.     ++$blocks{$fh};
  452.     substr($cpout{$fh}, 0, 5120) = '';
  453.     }
  454. }
  455.  
  456. sub flushall {
  457.     $name = 'TRAILER!!!';
  458.     foreach $fh (keys %cpout) {
  459.     &cpio($nc{$fh},$fh);
  460.     $cpout{$fh} .= "0" x (5120 - length($cpout{$fh}));
  461.     &flush($fh);
  462.     print $blocks{$fh} * 10, " blocks\n";
  463.     }
  464. }
  465.  
  466. END
  467. }
  468.  
  469. if ($inittar) {
  470. print <<'END';
  471. sub tar {
  472.     local($fh) = @_;
  473.     local($linkname,$header,$l,$slop);
  474.     local($linkflag) = "\0";
  475.  
  476.     ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
  477.       $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_);
  478.     $nm = $name;
  479.     if ($nlink > 1) {
  480.     if ($linkname = $linkseen{$fh,$dev,$ino}) {
  481.         $linkflag = 1;
  482.     }
  483.     else {
  484.         $linkseen{$fh,$dev,$ino} = $nm;
  485.     }
  486.     }
  487.     if (-f _) {
  488.     open(IN, "./$_\0") || do {
  489.         warn "Couldn't open $name: $!\n";
  490.         return;
  491.     };
  492.     $size = 0 if $linkflag ne "\0";
  493.     }
  494.     else {
  495.     $linkname = readlink($_);
  496.     $linkflag = 2 if defined $linkname;
  497.     $nm .= '/' if -d _;
  498.     $size = 0;
  499.     }
  500.  
  501.     $header = pack("a100a8a8a8a12a12a8a1a100",
  502.     $nm,
  503.     sprintf("%6o ", $mode & 0777),
  504.     sprintf("%6o ", $uid & 0777777),
  505.     sprintf("%6o ", $gid & 0777777),
  506.     sprintf("%11o ", $size),
  507.     sprintf("%11o ", $mtime),
  508.     "        ",
  509.     $linkflag,
  510.     $linkname);
  511.     $l = length($header) % 512;
  512.     substr($header, 148, 6) = sprintf("%6o", unpack("%16C*", $header));
  513.     substr($header, 154, 1) = "\0";  # blech
  514.     $tarout{$fh} .= $header;
  515.     $tarout{$fh} .= "\0" x (512 - $l) if $l;
  516.     if ($size) {
  517.     &tflush($fh) while ($l = length($tarout{$fh})) >= 10240;
  518.     while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) {
  519.         $slop = length($tarout{$fh}) % 512;
  520.         $tarout{$fh} .= "\0" x (512 - $slop) if $slop;
  521.         &tflush($fh);
  522.         $l = length($tarout{$fh});
  523.     }
  524.     }
  525.     close IN;
  526. }
  527.  
  528. sub tflush {
  529.     local($fh) = @_;
  530.  
  531.     while (length($tarout{$fh}) >= 10240) {
  532.     syswrite($fh,$tarout{$fh},10240);
  533.     ++$blocks{$fh};
  534.     substr($tarout{$fh}, 0, 10240) = '';
  535.     }
  536. }
  537.  
  538. sub tflushall {
  539.     local($len);
  540.  
  541.     foreach $fh (keys %tarout) {
  542.     $len = 10240 - length($tarout{$fh});
  543.     $len += 10240 if $len < 1024;
  544.     $tarout{$fh} .= "\0" x $len;
  545.     &tflush($fh);
  546.     }
  547. }
  548.  
  549. END
  550. }
  551.  
  552. exit;
  553.  
  554. ############################################################################
  555.  
  556. sub tab {
  557.     local($tabstring);
  558.  
  559.     $tabstring = "\t" x ($indent / 2) . ' ' x ($indent % 2 * 4);
  560.     if (!$statdone) {
  561.     if ($_ =~ /^(name|print|prune|exec|ok|\(|\))/) {
  562.         $delayedstat++;
  563.     }
  564.     else {
  565.         if ($saw_or) {
  566.         $tabstring .= <<'ENDOFSTAT' . $tabstring;
  567. ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) &&
  568. ENDOFSTAT
  569.         }
  570.         else {
  571.         $tabstring .= <<'ENDOFSTAT' . $tabstring;
  572. (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
  573. ENDOFSTAT
  574.         }
  575.         $statdone = 1;
  576.     }
  577.     }
  578.     $tabstring =~ s/^\s+/ / if $out =~ /!$/;
  579.     $tabstring;
  580. }
  581.  
  582. sub fileglob_to_re {
  583.     local($tmp) = @_;
  584.  
  585.     $tmp =~ s#([./^\$()])#\\$1#g;
  586.     $tmp =~ s/([?*])/.$1/g;
  587.     "^$tmp\$";
  588. }
  589.  
  590. sub n {
  591.     local($n) = @_;
  592.  
  593.     $n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /;
  594.     $n =~ s/ 0*(\d)/ $1/;
  595.     $n . ')';
  596. }
  597.  
  598. sub quote {
  599.     local($string) = @_;
  600.     $string =~ s/'/\\'/;
  601.     "'$string'";
  602. }
  603. !NO!SUBS!
  604.  
  605. close OUT or die "Can't close $file: $!";
  606. chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
  607. exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
  608.